Amiga Format CD 41/Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso/-seriously_amiga-/programming/other/scm/slib/scaexpp.scm

Text File | 1999-04-19 | 40KB | 2,957 lines

;;; "scaexpp.scm" syntax-case macros
;;; Copyright (C) 1992 R. Kent Dybvig
;;;
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full.  This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.

;;; Written by Robert Hieb & Kent Dybvig

;;; This file was munged by a simple minded sed script since it left
;;; its original authors' hands.  See syncase.sh for the horrid details.

(begin ((lambda ()
(letrec ((lambda-var-list (lambda (vars)
((letrec ((lvl (lambda (vars ls)
(if (pair? vars)
(lvl (cdr vars)
(cons (car vars)
ls))
(if (id? vars)
(cons vars
ls)
(if (null?
vars)
ls
(if (syntax-object?
vars)
(lvl (unwrap
vars)
ls)
(cons vars
ls))))))))
lvl)
vars
'())))
(gen-var (lambda (id) (gen-sym (id-sym-name id))))
(gen-sym (lambda (sym)
(syncase:new-symbol-hook (symbol->string sym))))
(strip (lambda (x)
(if (syntax-object? x)
(strip (syntax-object-expression x))
(if (pair? x)
((lambda (a d)
(if (if (eq? a (car x))
(eq? d (cdr x))
#f)
x
(cons a d)))
(strip (car x))
(strip (cdr x)))
(if (vector? x)
((lambda (old)
((lambda (new)
(if (syncase:andmap eq? old new)
x
(list->vector new)))
(map strip old)))
(vector->list x))
x)))))
(regen (lambda (x)
((lambda (g000139)
(if (memv g000139 '(ref))
(syncase:build-lexical-reference (cadr x))
(if (memv g000139 '(primitive))
(syncase:build-global-reference (cadr x))
(if (memv g000139 '(id))
(syncase:build-identifier (cadr x))
(if (memv g000139 '(quote))
(syncase:build-data (cadr x))
(if (memv
g000139
'(lambda))
(syncase:build-lambda
(cadr x)
(regen (caddr x)))
(begin g000139
(syncase:build-application
(syncase:build-global-reference
(car x))
(map regen
(cdr x))))))))))
(car x))))
(gen-vector (lambda (x)
(if (eq? (car x) 'list)
(syncase:list* 'vector (cdr x))
(if (eq? (car x) 'quote)
(list
'quote
(list->vector (cadr x)))
(list 'list->vector x)))))
(gen-append (lambda (x y)
(if (equal? y ''())
x
(list 'append x y))))
(gen-cons (lambda (x y)
(if (eq? (car y) 'list)
(syncase:list* 'list x (cdr y))
(if (if (eq? (car x) 'quote)
(eq? (car y) 'quote)
#f)
(list
'quote
(cons (cadr x) (cadr y)))
(if (equal? y ''())
(list 'list x)
(list 'cons x y))))))
(gen-map (lambda (e map-env)
((lambda (formals actuals)
(if (eq? (car e) 'ref)
(car actuals)
(if (syncase:andmap
(lambda (x)
(if (eq? (car x) 'ref)
(memq (cadr x)
formals)
#f))
(cdr e))
(syncase:list*
'map
(list 'primitive (car e))
(map ((lambda (r)
(lambda (x)
(cdr (assq (cadr x)
r))))
(map cons
formals
actuals))
(cdr e)))
(syncase:list*
'map
(list 'lambda formals e)
actuals))))
(map cdr map-env)
(map (lambda (x) (list 'ref (car x)))
map-env))))
(gen-ref (lambda (var level maps k)
(if (= level 0)
(k var maps)
(gen-ref
var
(- level 1)
(cdr maps)
(lambda (outer-var outer-maps)
((lambda (b)
(if b
(k (cdr b) maps)
((lambda (inner-var)
(k inner-var
(cons (cons (cons outer-var
inner-var)
(car maps))
outer-maps)))
(gen-sym var))))
(assq outer-var (car maps))))))))
(chi-syntax (lambda (src exp r w)
((letrec ((gen (lambda (e maps k)
(if (id? e)
((lambda (n)
((lambda (b)
(if (eq? (binding-type
b)
'syntax)
((lambda (level)
(if (< (length
maps)
level)
(syntax-error
src
"missing ellipsis in")
(gen-ref
n
level
maps
(lambda (x
maps)
(k (list
'ref
x)
maps)))))
(binding-value
b))
(if (ellipsis?
(wrap e
w))
(syntax-error
src
"invalid context for ... in")
(k (list
'id
(wrap e
w))
maps))))
(lookup
n
e
r)))
(id-var-name
e
w))
((lambda (g000141)
((lambda (g000142)
((lambda (g000140)
(if (not (eq? g000140
'no))
((lambda (_dots1
_dots2)
(if (if (ellipsis?
(wrap _dots1
w))
(ellipsis?
(wrap _dots2
w))
#f)
(k (list
'id
(wrap _dots1
w))
maps)
(g000142)))
(car g000140)
(cadr g000140))
(g000142)))
(syntax-dispatch
g000141
'(pair (any)
pair
(any)
atom)
(vector))))
(lambda ()
((lambda (g000144)
((lambda (g000145)
((lambda (g000143)
(if (not (eq? g000143
'no))
((lambda (_x
_dots
_y)
(if (ellipsis?
(wrap _dots
w))
(gen _y
maps
(lambda (y
maps)
(gen _x
(cons '()
maps)
(lambda (x
maps)
(if (null?
(car maps))
(syntax-error
src
"extra ellipsis in")
(k (gen-append
(gen-map
x
(car maps))
y)
(cdr maps)))))))
(g000145)))
(car g000143)
(cadr g000143)
(caddr
g000143))
(g000145)))
(syntax-dispatch
g000144
'(pair (any)
pair
(any)
any)
(vector))))
(lambda ()
((lambda (g000147)
((lambda (g000146)
(if (not (eq? g000146
'no))
((lambda (_x
_y)
(gen _x
maps
(lambda (x
maps)
(gen _y
maps
(lambda (y
maps)
(k (gen-cons
x
y)
maps))))))
(car g000146)
(cadr g000146))
((lambda (g000149)
((lambda (g000148)
(if (not (eq? g000148
'no))
((lambda (_e1
_e2)
(gen (cons _e1
_e2)
maps
(lambda (e
maps)
(k (gen-vector
e)
maps))))
(car g000148)
(cadr g000148))
((lambda (g000151)
((lambda (g000150)
(if (not (eq? g000150
'no))
((lambda (__)
(k (list
'quote
(wrap e
w))
maps))
(car g000150))
(syntax-error
g000151)))
(syntax-dispatch
g000151
'(any)
(vector))))
g000149)))
(syntax-dispatch
g000149
'(vector
pair
(any)
each
any)
(vector))))
g000147)))
(syntax-dispatch
g000147
'(pair (any)
any)
(vector))))
g000144))))
g000141))))
e)))))
gen)
exp
'()
(lambda (e maps) (regen e)))))
(ellipsis? (lambda (x)
;; I dont know what this is supposed to do, and removing it seemed harmless.
;; (if (if (top-level-bound? 'dp) dp #f)
;; (break)
;; (syncase:void))
(if (identifier? x)
(free-id=? x '...)
#f)))
(chi-syntax-definition (lambda (e w)
((lambda (g000153)
((lambda (g000154)
((lambda (g000152)
(if (not (eq? g000152
'no))
((lambda (__
_name
_val)
(if (id? _name)
(list _name
_val)
(g000154)))
(car g000152)
(cadr g000152)
(caddr
g000152))
(g000154)))
(syntax-dispatch
g000153
'(pair (any)
pair
(any)
pair
(any)
atom)
(vector))))
(lambda ()
(syntax-error
g000153))))
(wrap e w))))
(chi-definition (lambda (e w)
((lambda (g000156)
((lambda (g000157)
((lambda (g000155)
(if (not (eq? g000155
'no))
(apply
(lambda (__
_name
_args
_e1
_e2)
(if (if (id? _name)
(valid-bound-ids?
(lambda-var-list
_args))
#f)
(list _name
(cons '#(syntax-object
lambda
(top))
(cons _args
(cons _e1
_e2))))
(g000157)))
g000155)
(g000157)))
(syntax-dispatch
g000156
'(pair (any)
pair
(pair (any) any)
pair
(any)
each
any)
(vector))))
(lambda ()
((lambda (g000159)
((lambda (g000158)
(if (not (eq? g000158
'no))
((lambda (__
_name
_val)
(list _name
_val))
(car g000158)
(cadr g000158)
(caddr
g000158))
((lambda (g000161)
((lambda (g000162)
((lambda (g000160)
(if (not (eq? g000160
'no))
((lambda (__
_name)
(if (id? _name)
(list _name
(list '#(syntax-object
syncase:void
(top))))
(g000162)))
(car g000160)
(cadr g000160))
(g000162)))
(syntax-dispatch
g000161
'(pair (any)
pair
(any)
atom)
(vector))))
(lambda ()
(syntax-error
g000161))))
g000159)))
(syntax-dispatch
g000159
'(pair (any)
pair
(any)
pair
(any)
atom)
(vector))))
g000156))))
(wrap e w))))
(chi-sequence (lambda (e w)
((lambda (g000164)
((lambda (g000163)
(if (not (eq? g000163 'no))
((lambda (__ _e) _e)
(car g000163)
(cadr g000163))
(syntax-error g000164)))
(syntax-dispatch
g000164
'(pair (any) each any)
(vector))))
(wrap e w))))
(chi-macro-def (lambda (def r w)
(syncase:eval-hook (chi def null-env w))))
(chi-local-syntax (lambda (e r w)
((lambda (g000166)
((lambda (g000167)
((lambda (g000165)
(if (not (eq? g000165
'no))
(apply
(lambda (_who
_var
_val
_e1
_e2)
(if (valid-bound-ids?
_var)
((lambda (new-vars)
((lambda (new-w)
(chi-body
(cons _e1
_e2)
e
(extend-macro-env
new-vars
((lambda (w)
(map (lambda (x)
(chi-macro-def
x
r
w))
_val))
(if (free-id=?
_who
'#(syntax-object
letrec-syntax
(top)))
new-w
w))
r)
new-w))
(make-binding-wrap
_var
new-vars
w)))
(map gen-var
_var))
(g000167)))
g000165)
(g000167)))
(syntax-dispatch
g000166
'(pair (any)
pair
(each pair
(any)
pair
(any)
atom)
pair
(any)
each
any)
(vector))))
(lambda ()
((lambda (g000169)
((lambda (g000168)
(if (not (eq? g000168
'no))
((lambda (__)
(syntax-error
(wrap e
w)))
(car g000168))
(syntax-error
g000169)))
(syntax-dispatch
g000169
'(any)
(vector))))
g000166))))
e)))
(chi-body (lambda (body source r w)
(if (null? (cdr body))
(chi (car body) r w)
((letrec ((parse1 (lambda (body
var-ids
var-vals
macro-ids
macro-vals)
(if (null? body)
(syntax-error
(wrap source
w)
"no expressions in body")
((letrec ((parse2 (lambda (e)
((lambda (b)
((lambda (g000170)
(if (memv
g000170
'(macro))
(parse2
(chi-macro
(binding-value
b)
e
r
empty-wrap
(lambda (e
r
w)
(wrap e
w))))
(if (memv
g000170
'(definition))
(parse1
(cdr body)
(cons (cadr b)
var-ids)
(cons (caddr
b)
var-vals)
macro-ids
macro-vals)
(if (memv
g000170
'(syntax-definition))
(parse1
(cdr body)
var-ids
var-vals
(cons (cadr b)
macro-ids)
(cons (caddr
b)
macro-vals))
(if (memv
g000170
'(sequence))
(parse1
(append
(cdr b)
(cdr body))
var-ids
var-vals
macro-ids
macro-vals)
(begin g000170
(if (valid-bound-ids?
(append
var-ids
macro-ids))
((lambda (new-var-names
new-macro-names)
((lambda (w)
((lambda (r)
(syncase:build-letrec
new-var-names
(map (lambda (x)
(chi x
r
w))
var-vals)
(syncase:build-sequence
(map (lambda (x)
(chi x
r
w))
body))))
(extend-macro-env
new-macro-names
(map (lambda (x)
(chi-macro-def
x
r
w))
macro-vals)
(extend-var-env
new-var-names
r))))
(make-binding-wrap
(append
macro-ids
var-ids)
(append
new-macro-names
new-var-names)
empty-wrap)))
(map gen-var
var-ids)
(map gen-var
macro-ids))
(syntax-error
(wrap source
w)
"invalid identifier"))))))))
(car b)))
(syntax-type
e
r
empty-wrap)))))
parse2)
(car body))))))
parse1)
(map (lambda (x) (wrap x w)) body)
'()
'()
'()
'()))))
(syntax-type (lambda (e r w)
(if (syntax-object? e)
(syntax-type
(syntax-object-expression e)
r
(join-wraps
(syntax-object-wrap e)
w))
(if (if (pair? e)
(identifier? (car e))
#f)
((lambda (n)
((lambda (b)
((lambda (g000171)
(if (memv
g000171
'(special))
(if (memv
n
'(define))
(cons 'definition
(chi-definition
e
w))
(if (memv
n
'(define-syntax))
(cons 'syntax-definition
(chi-syntax-definition
e
w))
(if (memv
n
'(begin))
(cons 'sequence
(chi-sequence
e
w))
(begin n
(syncase:void)))))
(begin g000171
b)))
(binding-type b)))
(lookup n (car e) r)))
(id-var-name (car e) w))
'(other)))))
(chi-args (lambda (args r w source source-w)
(if (pair? args)
(cons (chi (car args) r w)
(chi-args
(cdr args)
r
w
source
source-w))
(if (null? args)
'()
(if (syntax-object? args)
(chi-args
(syntax-object-expression
args)
r
(join-wraps
w
(syntax-object-wrap
args))
source
source-w)
(syntax-error
(wrap source source-w)))))))
(chi-ref (lambda (e name binding w)
((lambda (g000172)
(if (memv g000172 '(lexical))
(syncase:build-lexical-reference name)
(if (memv
g000172
'(global global-unbound))
(syncase:build-global-reference name)
(begin g000172
(id-error
(wrap e w))))))
(binding-type binding))))
(chi-macro (letrec ((check-macro-output (lambda (x)
(if (pair?
x)
(begin (check-macro-output
(car x))
(check-macro-output
(cdr x)))
((lambda (g000173)
(if g000173
g000173
(if (vector?
x)
((lambda (n)
((letrec ((g000174 (lambda (i)
(if (= i
n)
(syncase:void)
(begin (check-macro-output
(vector-ref
x
i))
(g000174
(+ i
1)))))))
g000174)
0))
(vector-length
x))
(if (symbol?
x)
(syntax-error
x
"encountered raw symbol")
(syncase:void)))))
(syntax-object?
x))))))
(lambda (p e r w k)
((lambda (mw)
((lambda (x)
(check-macro-output x)
(k x r mw))
(p (wrap e (join-wraps mw w)))))
(new-mark-wrap)))))
(chi-pair (lambda (e r w k)
((lambda (first rest)
(if (id? first)
((lambda (n)
((lambda (b)
((lambda (g000175)
(if (memv
g000175
'(core))
((binding-value b)
e
r
w)
(if (memv
g000175
'(macro))
(chi-macro
(binding-value
b)
e
r
w
k)
(if (memv
g000175
'(special))
((binding-value
b)
e
r
w
k)
(begin g000175
(syncase:build-application
(chi-ref
first
n
b
w)
(chi-args
rest
r
w
e
w)))))))
(binding-type b)))
(lookup n first r)))
(id-var-name first w))
(syncase:build-application
(chi first r w)
(chi-args rest r w e w))))
(car e)
(cdr e))))
(chi (lambda (e r w)
(if (symbol? e)
((lambda (n)
(chi-ref e n (lookup n e r) w))
(id-var-name e w))
(if (pair? e)
(chi-pair e r w chi)
(if (syntax-object? e)
(chi (syntax-object-expression e)
r
(join-wraps
w
(syntax-object-wrap e)))
(if ((lambda (g000176)
(if g000176
g000176
((lambda (g000177)
(if g000177
g000177
((lambda (g000178)
(if g000178
g000178
(char?
e)))
(string? e))))
(number? e))))
(boolean? e))
(syncase:build-data e)
(syntax-error (wrap e w))))))))
(chi-top (lambda (e r w)
(if (pair? e)
(chi-pair e r w chi-top)
(if (syntax-object? e)
(chi-top
(syntax-object-expression e)
r
(join-wraps
w
(syntax-object-wrap e)))
(chi e r w)))))
(wrap (lambda (x w)
(if (null? w)
x
(if (syntax-object? x)
(make-syntax-object
(syntax-object-expression x)
(join-wraps
w
(syntax-object-wrap x)))
(if (null? x)
x
(make-syntax-object x w))))))
(unwrap (lambda (x)
(if (syntax-object? x)
((lambda (e w)
(if (pair? e)
(cons (wrap (car e) w)
(wrap (cdr e) w))
(if (vector? e)
(list->vector
(map (lambda (x)
(wrap x w))
(vector->list e)))
e)))
(syntax-object-expression x)
(syntax-object-wrap x))
x)))
(bound-id-member? (lambda (x list)
(if (not (null? list))
((lambda (g000179)
(if g000179
g000179
(bound-id-member?
x
(cdr list))))
(bound-id=? x (car list)))
#f)))
(valid-bound-ids? (lambda (ids)
(if ((letrec ((all-ids? (lambda (ids)
((lambda (g000181)
(if g000181
g000181
(if (id? (car ids))
(all-ids?
(cdr ids))
#f)))
(null?
ids)))))
all-ids?)
ids)
((letrec ((unique? (lambda (ids)
((lambda (g000180)
(if g000180
g000180
(if (not (bound-id-member?
(car ids)
(cdr ids)))
(unique?
(cdr ids))
#f)))
(null?
ids)))))
unique?)
ids)
#f)))
(bound-id=? (lambda (i j)
(if (eq? (id-sym-name i)
(id-sym-name j))
((lambda (i j)
(if (eq? (car i) (car j))
(same-marks?
(cdr i)
(cdr j))
#f))
(id-var-name&marks i empty-wrap)
(id-var-name&marks j empty-wrap))
#f)))
(free-id=? (lambda (i j)
(if (eq? (id-sym-name i) (id-sym-name j))
(eq? (id-var-name i empty-wrap)
(id-var-name j empty-wrap))
#f)))
(id-var-name&marks (lambda (id w)
(if (null? w)
(if (symbol? id)
(list id)
(id-var-name&marks
(syntax-object-expression
id)
(syntax-object-wrap
id)))
((lambda (n&m first)
(if (pair? first)
((lambda (n)
((letrec ((search (lambda (rib)
(if (null?
rib)
n&m
(if (if (eq? (caar rib)
n)
(same-marks?
(cdr n&m)
(cddar
rib))
#f)
(cdar rib)
(search
(cdr rib)))))))
search)
first))
(car n&m))
(cons (car n&m)
(if ((lambda (g000182)
(if g000182
g000182
(not (eqv? first
(cadr n&m)))))
(null?
(cdr n&m)))
(cons first
(cdr n&m))
(cddr n&m)))))
(id-var-name&marks
id
(cdr w))
(car w)))))
(id-var-name (lambda (id w)
(if (null? w)
(if (symbol? id)
id
(id-var-name
(syntax-object-expression
id)
(syntax-object-wrap id)))
(if (pair? (car w))
(car (id-var-name&marks id w))
(id-var-name id (cdr w))))))
(same-marks? (lambda (x y)
(if (null? x)
(null? y)
(if (not (null? y))
(if (eqv? (car x) (car y))
(same-marks?
(cdr x)
(cdr y))
#f)
#f))))
(join-wraps2 (lambda (w1 w2)
((lambda (x w1)
(if (null? w1)
(if (if (not (pair? x))
(eqv? x (car w2))
#f)
(cdr w2)
(cons x w2))
(cons x (join-wraps2 w1 w2))))
(car w1)
(cdr w1))))
(join-wraps1 (lambda (w1 w2)
(if (null? w1)
w2
(cons (car w1)
(join-wraps1 (cdr w1) w2)))))
(join-wraps (lambda (w1 w2)
(if (null? w2)
w1
(if (null? w1)
w2
(if (pair? (car w2))
(join-wraps1 w1 w2)
(join-wraps2 w1 w2))))))
(make-wrap-rib (lambda (ids new-names w)
(if (null? ids)
'()
(cons ((lambda (n&m)
(cons (car n&m)
(cons (car new-names)
(cdr n&m))))
(id-var-name&marks
(car ids)
w))
(make-wrap-rib
(cdr ids)
(cdr new-names)
w)))))
(make-binding-wrap (lambda (ids new-names w)
(if (null? ids)
w
(cons (make-wrap-rib
ids
new-names
w)
w))))
(new-mark-wrap (lambda ()
(set! current-mark
(+ current-mark 1))
(list current-mark)))
(current-mark 0)
(top-wrap '(top))
(empty-wrap '())
(id-sym-name (lambda (x)
(if (symbol? x)
x
(syntax-object-expression x))))
(id? (lambda (x)
((lambda (g000183)
(if g000183
g000183
(if (syntax-object? x)
(symbol?
(syntax-object-expression x))
#f)))
(symbol? x))))
(global-extend (lambda (type sym val)
(extend-global-env
sym
(cons type val))))
(lookup (lambda (name id r)
(if (eq? name (id-sym-name id))
(global-lookup name)
((letrec ((search (lambda (r name)
(if (null? r)
'(displaced-lexical)
(if (pair?
(car r))
(if (eq? (caar r)
name)
(cdar r)
(search
(cdr r)
name))
(if (eq? (car r)
name)
'(lexical)
(search
(cdr r)
name)))))))
search)
r
name))))
(extend-syntax-env (lambda (vars vals r)
(if (null? vars)
r
(cons (cons (car vars)
(cons 'syntax
(car vals)))
(extend-syntax-env
(cdr vars)
(cdr vals)
r)))))
(extend-var-env append)
(extend-macro-env (lambda (vars vals r)
(if (null? vars)
r
(cons (cons (car vars)
(cons 'macro
(car vals)))
(extend-macro-env
(cdr vars)
(cdr vals)
r)))))
(null-env '())
(global-lookup (lambda (sym)
((lambda (g000184)
(if g000184
g000184
'(global-unbound)))
(syncase:get-global-definition-hook sym))))
(extend-global-env (lambda (sym binding)
(syncase:put-global-definition-hook
sym
binding)))
(binding-value cdr)
(binding-type car)
(arg-check (lambda (pred? x who)
(if (not (pred? x))
(syncase:error-hook who "invalid argument" x)
(syncase:void))))
(id-error (lambda (x)
(syntax-error
x
"invalid context for identifier")))
(scope-error (lambda (id)
(syntax-error
id
"invalid context for bound identifier")))
(syntax-object-wrap (lambda (x) (vector-ref x 2)))
(syntax-object-expression (lambda (x) (vector-ref x 1)))
(make-syntax-object (lambda (expression wrap)
(vector
'syntax-object
expression
wrap)))
(syntax-object? (lambda (x)
(if (vector? x)
(if (= (vector-length x) 3)
(eq? (vector-ref x 0)
'syntax-object)
#f)
#f))))
(global-extend 'core 'letrec-syntax chi-local-syntax)
(global-extend 'core 'let-syntax chi-local-syntax)
(global-extend
'core
'quote
(lambda (e r w)
((lambda (g000136)
((lambda (g000135)
(if (not (eq? g000135 'no))
((lambda (__ _e) (syncase:build-data (strip _e)))
(car g000135)
(cadr g000135))
((lambda (g000138)
((lambda (g000137)
(if (not (eq? g000137 'no))
((lambda (__)
(syntax-error (wrap e w)))
(car g000137))
(syntax-error g000138)))
(syntax-dispatch
g000138
'(any)
(vector))))
g000136)))
(syntax-dispatch
g000136
'(pair (any) pair (any) atom)
(vector))))
e)))
(global-extend
'core
'syntax
(lambda (e r w)
((lambda (g000132)
((lambda (g000131)
(if (not (eq? g000131 'no))
((lambda (__ _x) (chi-syntax e _x r w))
(car g000131)
(cadr g000131))
((lambda (g000134)
((lambda (g000133)
(if (not (eq? g000133 'no))
((lambda (__)
(syntax-error (wrap e w)))
(car g000133))
(syntax-error g000134)))
(syntax-dispatch
g000134
'(any)
(vector))))
g000132)))
(syntax-dispatch
g000132
'(pair (any) pair (any) atom)
(vector))))
e)))
(global-extend
'core
'syntax-lambda
(lambda (e r w)
((lambda (g000127)
((lambda (g000128)
((lambda (g000126)
(if (not (eq? g000126 'no))
((lambda (__ _id _level _exp)
(if (if (valid-bound-ids? _id)
(map (lambda (x)
(if (integer? x)
(if (exact? x)
(not (negative?
x))
#f)
#f))
(map unwrap _level))
#f)
((lambda (new-vars)
(syncase:build-lambda
new-vars
(chi _exp
(extend-syntax-env
new-vars
(map unwrap
_level)
r)
(make-binding-wrap
_id
new-vars
w))))
(map gen-var _id))
(g000128)))
(car g000126)
(cadr g000126)
(caddr g000126)
(cadddr g000126))
(g000128)))
(syntax-dispatch
g000127
'(pair (any)
pair
(each pair (any) pair (any) atom)
pair
(any)
atom)
(vector))))
(lambda ()
((lambda (g000130)
((lambda (g000129)
(if (not (eq? g000129 'no))
((lambda (__)
(syntax-error (wrap e w)))
(car g000129))
(syntax-error g000130)))
(syntax-dispatch
g000130
'(any)
(vector))))
g000127))))
e)))
(global-extend
'core
'lambda
(lambda (e r w)
((lambda (g000121)
((lambda (g000120)
(if (not (eq? g000120 'no))
((lambda (__ _id _e1 _e2)
(if (not (valid-bound-ids? _id))
(syntax-error
(wrap e w)
"invalid parameter list")
((lambda (new-vars)
(syncase:build-lambda
new-vars
(chi-body
(cons _e1 _e2)
e
(extend-var-env
new-vars
r)
(make-binding-wrap
_id
new-vars
w))))
(map gen-var _id))))
(car g000120)
(cadr g000120)
(caddr g000120)
(cadddr g000120))
((lambda (g000123)
((lambda (g000122)
(if (not (eq? g000122 'no))
((lambda (__ _ids _e1 _e2)
((lambda (old-ids)
(if (not (valid-bound-ids?
(lambda-var-list
_ids)))
(syntax-error
(wrap e w)
"invalid parameter list")
((lambda (new-vars)
(syncase:build-improper-lambda
(reverse
(cdr new-vars))
(car new-vars)
(chi-body
(cons _e1
_e2)
e
(extend-var-env
new-vars
r)
(make-binding-wrap
old-ids
new-vars
w))))
(map gen-var
old-ids))))
(lambda-var-list _ids)))
(car g000122)
(cadr g000122)
(caddr g000122)
(cadddr g000122))
((lambda (g000125)
((lambda (g000124)
(if (not (eq? g000124
'no))
((lambda (__)
(syntax-error
(wrap e w)))
(car g000124))
(syntax-error
g000125)))
(syntax-dispatch
g000125
'(any)
(vector))))
g000123)))
(syntax-dispatch
g000123
'(pair (any)
pair
(any)
pair
(any)
each
any)
(vector))))
g000121)))
(syntax-dispatch
g000121
'(pair (any)
pair
(each any)
pair
(any)
each
any)
(vector))))
e)))
(global-extend
'core
'letrec
(lambda (e r w)
((lambda (g000116)
((lambda (g000117)
((lambda (g000115)
(if (not (eq? g000115 'no))
(apply
(lambda (__ _id _val _e1 _e2)
(if (valid-bound-ids? _id)
((lambda (new-vars)
((lambda (w r)
(syncase:build-letrec
new-vars
(map (lambda (x)
(chi x
r
w))
_val)
(chi-body
(cons _e1 _e2)
e
r
w)))
(make-binding-wrap
_id
new-vars
w)
(extend-var-env
new-vars
r)))
(map gen-var _id))
(g000117)))
g000115)
(g000117)))
(syntax-dispatch
g000116
'(pair (any)
pair
(each pair (any) pair (any) atom)
pair
(any)
each
any)
(vector))))
(lambda ()
((lambda (g000119)
((lambda (g000118)
(if (not (eq? g000118 'no))
((lambda (__)
(syntax-error (wrap e w)))
(car g000118))
(syntax-error g000119)))
(syntax-dispatch
g000119
'(any)
(vector))))
g000116))))
e)))
(global-extend
'core
'if
(lambda (e r w)
((lambda (g000110)
((lambda (g000109)
(if (not (eq? g000109 'no))
((lambda (__ _test _then)
(syncase:build-conditional
(chi _test r w)
(chi _then r w)
(chi (list '#(syntax-object
syncase:void
(top)))
r
empty-wrap)))
(car g000109)
(cadr g000109)
(caddr g000109))
((lambda (g000112)
((lambda (g000111)
(if (not (eq? g000111 'no))
((lambda (__ _test _then _else)
(syncase:build-conditional
(chi _test r w)
(chi _then r w)
(chi _else r w)))
(car g000111)
(cadr g000111)
(caddr g000111)
(cadddr g000111))
((lambda (g000114)
((lambda (g000113)
(if (not (eq? g000113
'no))
((lambda (__)
(syntax-error
(wrap e w)))
(car g000113))
(syntax-error
g000114)))
(syntax-dispatch
g000114
'(any)
(vector))))
g000112)))
(syntax-dispatch
g000112
'(pair (any)
pair
(any)
pair
(any)
pair
(any)
atom)
(vector))))
g000110)))
(syntax-dispatch
g000110
'(pair (any) pair (any) pair (any) atom)
(vector))))
e)))
(global-extend
'core
'set!
(lambda (e r w)
((lambda (g000104)
((lambda (g000105)
((lambda (g000103)
(if (not (eq? g000103 'no))
((lambda (__ _id _val)
(if (id? _id)
((lambda (val n)
((lambda (g000108)
(if (memv
g000108
'(lexical))
(syncase:build-lexical-assignment
n
val)
(if (memv
g000108
'(global
global-unbound))
(syncase:build-global-assignment
n
val)
(begin g000108
(id-error
(wrap _id
w))))))
(binding-type
(lookup n _id r))))
(chi _val r w)
(id-var-name _id w))
(g000105)))
(car g000103)
(cadr g000103)
(caddr g000103))
(g000105)))
(syntax-dispatch
g000104
'(pair (any) pair (any) pair (any) atom)
(vector))))
(lambda ()
((lambda (g000107)
((lambda (g000106)
(if (not (eq? g000106 'no))
((lambda (__)
(syntax-error (wrap e w)))
(car g000106))
(syntax-error g000107)))
(syntax-dispatch
g000107
'(any)
(vector))))
g000104))))
e)))
(global-extend
'special
'begin
(lambda (e r w k)
((lambda (body)
(if (null? body)
(if (eqv? k chi-top)
(chi (list '#(syntax-object syncase:void (top)))
r
empty-wrap)
(syntax-error
(wrap e w)
"no expressions in body of"))
(syncase:build-sequence
((letrec ((dobody (lambda (body)
(if (null? body)
'()
((lambda (first)
(cons first
(dobody
(cdr body))))
(k (car body)
r
empty-wrap))))))
dobody)
body))))
(chi-sequence e w))))
(global-extend
'special
'define
(lambda (e r w k)
(if (eqv? k chi-top)
((lambda (n&v)
((lambda (n)
(global-extend 'global n '())
(syncase:build-global-definition
n
(chi (cadr n&v) r empty-wrap)))
(id-var-name (car n&v) empty-wrap)))
(chi-definition e w))
(syntax-error
(wrap e w)
"invalid context for definition"))))
(global-extend
'special
'define-syntax
(lambda (e r w k)
(if (eqv? k chi-top)
((lambda (n&v)
(global-extend
'macro
(id-var-name (car n&v) empty-wrap)
(chi-macro-def (cadr n&v) r empty-wrap))
(chi (list '#(syntax-object syncase:void (top)))
r
empty-wrap))
(chi-syntax-definition e w))
(syntax-error
(wrap e w)
"invalid context for definition"))))
(set! expand-syntax
(lambda (x) (chi-top x null-env top-wrap)))
(set! implicit-identifier
(lambda (id sym)
(arg-check id? id 'implicit-identifier)
(arg-check symbol? sym 'implicit-identifier)
(if (syntax-object? id)
(wrap sym (syntax-object-wrap id))
sym)))
(set! syntax-object->datum (lambda (x) (strip x)))
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(map (lambda (x) (wrap (syncase:new-symbol-hook "g") top-wrap)) ls)))
(set! free-identifier=?
(lambda (x y)
(arg-check id? x 'free-identifier=?)
(arg-check id? y 'free-identifier=?)
(free-id=? x y)))
(set! bound-identifier=?
(lambda (x y)
(arg-check id? x 'bound-identifier=?)
(arg-check id? y 'bound-identifier=?)
(bound-id=? x y)))
(set! identifier? (lambda (x) (id? x)))
(set! syntax-error
(lambda (object . messages)
(for-each
(lambda (x) (arg-check string? x 'syntax-error))
messages)
((lambda (message)
(syncase:error-hook 'expand-syntax message (strip object)))
(if (null? messages)
"invalid syntax"
(apply string-append messages)))))
(set! syncase:install-global-transformer
(lambda (sym p) (global-extend 'macro sym p)))
((lambda ()
(letrec ((match (lambda (e p k w r)
(if (eq? r 'no)
r
((lambda (g000100)
(if (memv g000100 '(any))
(cons (wrap e w) r)
(if (memv
g000100
'(free-id))
(if (if (identifier?
e)
(free-id=?
(wrap e w)
(vector-ref
k
(cdr p)))
#f)
r
'no)
(begin g000100
(if (syntax-object?
e)
(match*
(syntax-object-expression
e)
p
k
(join-wraps
w
(syntax-object-wrap
e))
r)
(match*
e
p
k
w
r))))))
(car p)))))
(match* (lambda (e p k w r)
((lambda (g000101)
(if (memv g000101 '(pair))
(if (pair? e)
(match
(car e)
(cadr p)
k
w
(match
(cdr e)
(cddr p)
k
w
r))
'no)
(if (memv g000101 '(each))
(if (eq? (cadr p) 'any)
((lambda (l)
(if (eq? l 'no)
l
(cons l r)))
(match-each-any
e
w))
(if (null? e)
(match-empty
(cdr p)
r)
((lambda (l)
(if (eq? l
'no)
l
((letrec ((collect (lambda (l)
(if (null?
(car l))
r
(cons (map car
l)
(collect
(map cdr
l)))))))
collect)
l)))
(match-each
e
(cdr p)
k
w))))
(if (memv
g000101
'(atom))
(if (equal?
(cdr p)
e)
r
'no)
(if (memv
g000101
'(vector))
(if (vector? e)
(match
(vector->list
e)
(cdr p)
k
w
r)
'no)
(begin g000101
(syncase:void)))))))
(car p))))
(match-empty (lambda (p r)
((lambda (g000102)
(if (memv g000102 '(any))
(cons '() r)
(if (memv
g000102
'(each))
(match-empty
(cdr p)
r)
(if (memv
g000102
'(pair))
(match-empty
(cadr p)
(match-empty
(cddr p)
r))
(if (memv
g000102
'(free-id
atom))
r
(if (memv
g000102
'(vector))
(match-empty
(cdr p)
r)
(begin g000102
(syncase:void))))))))
(car p))))
(match-each-any (lambda (e w)
(if (pair? e)
((lambda (l)
(if (eq? l 'no)
l
(cons (wrap (car e)
w)
l)))
(match-each-any
(cdr e)
w))
(if (null? e)
'()
(if (syntax-object?
e)
(match-each-any
(syntax-object-expression
e)
(join-wraps
w
(syntax-object-wrap
e)))
'no)))))
(match-each (lambda (e p k w)
(if (pair? e)
((lambda (first)
(if (eq? first 'no)
first
((lambda (rest)
(if (eq? rest
'no)
rest
(cons first
rest)))
(match-each
(cdr e)
p
k
w))))
(match (car e) p k w '()))
(if (null? e)
'()
(if (syntax-object? e)
(match-each
(syntax-object-expression
e)
p
k
(join-wraps
w
(syntax-object-wrap
e)))
'no))))))
(set! syntax-dispatch
(lambda (expression pattern keys)
(match
expression
pattern
keys
empty-wrap
'())))))))))
(syncase:install-global-transformer
'let
(lambda (x)
((lambda (g00095)
((lambda (g00096)
((lambda (g00094)
(if (not (eq? g00094 'no))
(apply
(lambda (__ _x _v _e1 _e2)
(if (syncase:andmap identifier? _x)
(cons (cons '#(syntax-object
lambda
(top))
(cons _x
(cons _e1 _e2)))
_v)
(g00096)))
g00094)
(g00096)))
(syntax-dispatch
g00095
'(pair (any)
pair
(each pair (any) pair (any) atom)
pair
(any)
each
any)
(vector))))
(lambda ()
((lambda (g00098)
((lambda (g00099)
((lambda (g00097)
(if (not (eq? g00097 'no))
(apply
(lambda (__ _f _x _v _e1 _e2)
(if (syncase:andmap
identifier?
(cons _f _x))
(cons (list '#(syntax-object
letrec
(top))
(list (list _f
(cons '#(syntax-object
lambda
(top))
(cons _x
(cons _e1
_e2)))))
_f)
_v)
(g00099)))
g00097)
(g00099)))
(syntax-dispatch
g00098
'(pair (any)
pair
(any)
pair
(each pair (any) pair (any) atom)
pair
(any)
each
any)
(vector))))
(lambda () (syntax-error g00098))))
g00095))))
x)))
(syncase:install-global-transformer
'syntax-case
((lambda ()
(letrec ((syncase:build-dispatch-call (lambda (args body val)
((lambda (g00046)
((lambda (g00045)
(if (not (eq? g00045
'no))
body
((lambda (g00048)
((lambda (g00047)
(if (not (eq? g00047
'no))
((lambda (_arg1)
((lambda (g00066)
((lambda (g00065)
(if (not (eq? g00065
'no))
((lambda (_body
_val)
(list (list '#(syntax-object
syntax-lambda
(top))
(list _arg1)
_body)
(list '#(syntax-object
car
(top))
_val)))
(car g00065)
(cadr g00065))
(syntax-error
g00066)))
(syntax-dispatch
g00066
'(pair (any)
pair
(any)
atom)
(vector))))
(list body
val)))
(car g00047))
((lambda (g00050)
((lambda (g00049)
(if (not (eq? g00049
'no))
((lambda (_arg1
_arg2)
((lambda (g00064)
((lambda (g00063)
(if (not (eq? g00063
'no))
((lambda (_body
_val)
(list (list '#(syntax-object
syntax-lambda
(top))
(list _arg1
_arg2)
_body)
(list '#(syntax-object
car
(top))
_val)
(list '#(syntax-object
cadr
(top))
_val)))
(car g00063)
(cadr g00063))
(syntax-error
g00064)))
(syntax-dispatch
g00064
'(pair (any)
pair
(any)
atom)
(vector))))
(list body
val)))
(car g00049)
(cadr g00049))
((lambda (g00052)
((lambda (g00051)
(if (not (eq? g00051
'no))
((lambda (_arg1
_arg2
_arg3)
((lambda (g00062)
((lambda (g00061)
(if (not (eq? g00061
'no))
((lambda (_body
_val)
(list (list '#(syntax-object
syntax-lambda
(top))
(list _arg1
_arg2
_arg3)
_body)
(list '#(syntax-object
car
(top))
_val)
(list '#(syntax-object
cadr
(top))
_val)
(list '#(syntax-object
caddr
(top))
_val)))
(car g00061)
(cadr g00061))
(syntax-error
g00062)))
(syntax-dispatch
g00062
'(pair (any)
pair
(any)
atom)
(vector))))
(list body
val)))
(car g00051)
(cadr g00051)
(caddr
g00051))
((lambda (g00054)
((lambda (g00053)
(if (not (eq? g00053
'no))
((lambda (_arg1
_arg2
_arg3
_arg4)
((lambda (g00060)
((lambda (g00059)
(if (not (eq? g00059
'no))
((lambda (_body
_val)
(list (list '#(syntax-object
syntax-lambda
(top))
(list _arg1
_arg2
_arg3
_arg4)
_body)
(list '#(syntax-object
car
(top))
_val)
(list '#(syntax-object
cadr
(top))
_val)
(list '#(syntax-object
caddr
(top))
_val)
(list '#(syntax-object
cadddr
(top))
_val)))
(car g00059)
(cadr g00059))
(syntax-error
g00060)))
(syntax-dispatch
g00060
'(pair (any)
pair
(any)
atom)
(vector))))
(list body
val)))
(car g00053)
(cadr g00053)
(caddr
g00053)
(cadddr
g00053))
((lambda (g00056)
((lambda (g00055)
(if (not (eq? g00055
'no))
((lambda (_arg)
((lambda (g00058)
((lambda (g00057)
(if (not (eq? g00057
'no))
((lambda (_body
_val)
(list '#(syntax-object
apply
(top))
(list '#(syntax-object
syntax-lambda
(top))
_arg
_body)
_val))
(car g00057)
(cadr g00057))
(syntax-error
g00058)))
(syntax-dispatch
g00058
'(pair (any)
pair
(any)
atom)
(vector))))
(list body
val)))
(car g00055))
(syntax-error
g00056)))
(syntax-dispatch
g00056
'(each any)
(vector))))
g00054)))
(syntax-dispatch
g00054
'(pair (any)
pair
(any)
pair
(any)
pair
(any)
atom)
(vector))))
g00052)))
(syntax-dispatch
g00052
'(pair (any)
pair
(any)
pair
(any)
atom)
(vector))))
g00050)))
(syntax-dispatch
g00050
'(pair (any)
pair
(any)
atom)
(vector))))
g00048)))
(syntax-dispatch
g00048
'(pair (any)
atom)
(vector))))
g00046)))
(syntax-dispatch
g00046
'(atom)
(vector))))
args)))
(extract-bound-syntax-ids (lambda (pattern keys)
((letrec ((gen (lambda (p
n
ids)
(if (identifier?
p)
(if (key? p
keys)
ids
(cons (list p
n)
ids))
((lambda (g00068)
((lambda (g00069)
((lambda (g00067)
(if (not (eq? g00067
'no))
((lambda (_x
_dots)
(if (ellipsis?
_dots)
(gen _x
(+ n
1)
ids)
(g00069)))
(car g00067)
(cadr g00067))
(g00069)))
(syntax-dispatch
g00068
'(pair (any)
pair
(any)
atom)
(vector))))
(lambda ()
((lambda (g00071)
((lambda (g00070)
(if (not (eq? g00070
'no))
((lambda (_x
_y)
(gen _x
n
(gen _y
n
ids)))
(car g00070)
(cadr g00070))
((lambda (g00073)
((lambda (g00072)
(if (not (eq? g00072
'no))
((lambda (_x)
(gen _x
n
ids))
(car g00072))
((lambda (g00075)
((lambda (g00074)
(if (not (eq? g00074
'no))
((lambda (_x)
ids)
(car g00074))
(syntax-error
g00075)))
(syntax-dispatch
g00075
'(any)
(vector))))
g00073)))
(syntax-dispatch
g00073
'(vector
each
any)
(vector))))
g00071)))
(syntax-dispatch
g00071
'(pair (any)
any)
(vector))))
g00068))))
p)))))
gen)
pattern
0
'())))
(valid-syntax-pattern? (lambda (pattern keys)
(letrec ((check? (lambda (p
ids)
(if (identifier?
p)
(if (eq? ids
'no)
ids
(if (key? p
keys)
ids
(if (if (not (ellipsis?
p))
(not (memid
p
ids))
#f)
(cons p
ids)
'no)))
((lambda (g00077)
((lambda (g00078)
((lambda (g00076)
(if (not (eq? g00076
'no))
((lambda (_x
_dots)
(if (ellipsis?
_dots)
(check?
_x
ids)
(g00078)))
(car g00076)
(cadr g00076))
(g00078)))
(syntax-dispatch
g00077
'(pair (any)
pair
(any)
atom)
(vector))))
(lambda ()
((lambda (g00080)
((lambda (g00079)
(if (not (eq? g00079
'no))
((lambda (_x
_y)
(check?
_x
(check?
_y
ids)))
(car g00079)
(cadr g00079))
((lambda (g00082)
((lambda (g00081)
(if (not (eq? g00081
'no))
((lambda (_x)
(check?
_x
ids))
(car g00081))
((lambda (g00084)
((lambda (g00083)
(if (not (eq? g00083
'no))
((lambda (_x)
ids)
(car g00083))
(syntax-error
g00084)))
(syntax-dispatch
g00084
'(any)
(vector))))
g00082)))
(syntax-dispatch
g00082
'(vector
each
any)
(vector))))
g00080)))
(syntax-dispatch
g00080
'(pair (any)
any)
(vector))))
g00077))))
p)))))
(not (eq? (check?
pattern
'())
'no)))))
(valid-keyword? (lambda (k)
(if (identifier? k)
(not (free-identifier=?
k
'...))
#f)))
(convert-syntax-dispatch-pattern (lambda (pattern
keys)
((letrec ((gen (lambda (p)
(if (identifier?
p)
(if (key? p
keys)
(cons '#(syntax-object
free-id
(top))
(key-index
p
keys))
(list '#(syntax-object
any
(top))))
((lambda (g00086)
((lambda (g00087)
((lambda (g00085)
(if (not (eq? g00085
'no))
((lambda (_x
_dots)
(if (ellipsis?
_dots)
(cons '#(syntax-object
each
(top))
(gen _x))
(g00087)))
(car g00085)
(cadr g00085))
(g00087)))
(syntax-dispatch
g00086
'(pair (any)
pair
(any)
atom)
(vector))))
(lambda ()
((lambda (g00089)
((lambda (g00088)
(if (not (eq? g00088
'no))
((lambda (_x
_y)
(cons '#(syntax-object
pair
(top))
(cons (gen _x)
(gen _y))))
(car g00088)
(cadr g00088))
((lambda (g00091)
((lambda (g00090)
(if (not (eq? g00090
'no))
((lambda (_x)
(cons '#(syntax-object
vector
(top))
(gen _x)))
(car g00090))
((lambda (g00093)
((lambda (g00092)
(if (not (eq? g00092
'no))
((lambda (_x)
(cons '#(syntax-object
atom
(top))
p))
(car g00092))
(syntax-error
g00093)))
(syntax-dispatch
g00093
'(any)
(vector))))
g00091)))
(syntax-dispatch
g00091
'(vector
each
any)
(vector))))
g00089)))
(syntax-dispatch
g00089
'(pair (any)
any)
(vector))))
g00086))))
p)))))
gen)
pattern)))
(key-index (lambda (p keys)
(- (length keys)
(length (memid p keys)))))
(key? (lambda (p keys)
(if (identifier? p) (memid p keys) #f)))
(memid (lambda (i ids)
(if (not (null? ids))
(if (bound-identifier=? i (car ids))
ids
(memid i (cdr ids)))
#f)))
(ellipsis? (lambda (x)
(if (identifier? x)
(free-identifier=? x '...)
#f))))
(lambda (x)
((lambda (g00030)
((lambda (g00031)
((lambda (g00029)
(if (not (eq? g00029 'no))
((lambda (__ _val _key)
(if (syncase:andmap valid-keyword? _key)
(list '#(syntax-object
syntax-error
(top))
_val)
(g00031)))
(car g00029)
(cadr g00029)
(caddr g00029))
(g00031)))
(syntax-dispatch
g00030
'(pair (any)
pair
(any)
pair
(each any)
atom)
(vector))))
(lambda ()
((lambda (g00033)
((lambda (g00034)
((lambda (g00032)
(if (not (eq? g00032 'no))
(apply
(lambda (__
_val
_key
_pat
_exp)
(if (if (identifier?
_pat)
(if (syncase:andmap
valid-keyword?
_key)
(syncase:andmap
(lambda (x)
(not (free-identifier=?
_pat
x)))
(cons '...
_key))
#f)
#f)
(list (list '#(syntax-object
syntax-lambda
(top))
(list (list _pat
0))
_exp)
_val)
(g00034)))
g00032)
(g00034)))
(syntax-dispatch
g00033
'(pair (any)
pair
(any)
pair
(each any)
pair
(pair (any) pair (any) atom)
atom)
(vector))))
(lambda ()
((lambda (g00036)
((lambda (g00037)
((lambda (g00035)
(if (not (eq? g00035 'no))
(apply
(lambda (__
_val
_key
_pat
_exp
_e1
_e2
_e3)
(if (if (syncase:andmap
valid-keyword?
_key)
(valid-syntax-pattern?
_pat
_key)
#f)
((lambda (g00044)
((lambda (g00043)
(if (not (eq? g00043
'no))
((lambda (_pattern
_y
_call)
(list '#(syntax-object
let
(top))
(list (list '#(syntax-object
x
(top))
_val))
(list '#(syntax-object
let
(top))
(list (list _y
(list '#(syntax-object
syntax-dispatch
(top))
'#(syntax-object
x
(top))
(list '#(syntax-object
quote
(top))
_pattern)
(list '#(syntax-object
syntax
(top))
(list->vector
_key)))))
(list '#(syntax-object
if
(top))
(list '#(syntax-object
not
(top))
(list '#(syntax-object
eq?
(top))
_y
(list '#(syntax-object
quote
(top))
'#(syntax-object
no
(top)))))
_call
(cons '#(syntax-object
syntax-case
(top))
(cons '#(syntax-object
x
(top))
(cons _key
(map (lambda (__e1
__e2
__e3)
(cons __e1
(cons __e2
__e3)))
_e1
_e2
_e3))))))))
(car g00043)
(cadr g00043)
(caddr
g00043))
(syntax-error
g00044)))
(syntax-dispatch
g00044
'(pair (any)
pair
(any)
pair
(any)
atom)
(vector))))
(list (convert-syntax-dispatch-pattern
_pat
_key)
'#(syntax-object
y
(top))
(syncase:build-dispatch-call
(extract-bound-syntax-ids
_pat
_key)
_exp
'#(syntax-object
y
(top)))))
(g00037)))
g00035)
(g00037)))
(syntax-dispatch
g00036
'(pair (any)
pair
(any)
pair
(each any)
pair
(pair (any)
pair
(any)
atom)
each
pair
(any)
pair
(any)
each
any)
(vector))))
(lambda ()
((lambda (g00039)
((lambda (g00040)
((lambda (g00038)
(if (not (eq? g00038
'no))
(apply
(lambda (__
_val
_key
_pat
_fender
_exp
_e1
_e2
_e3)
(if (if (syncase:andmap
valid-keyword?
_key)
(valid-syntax-pattern?
_pat
_key)
#f)
((lambda (g00042)
((lambda (g00041)
(if (not (eq? g00041
'no))
((lambda (_pattern
_y
_dorest
_call)
(list '#(syntax-object
let
(top))
(list (list '#(syntax-object
x
(top))
_val))
(list '#(syntax-object
let
(top))
(list (list _dorest
(list '#(syntax-object
lambda
(top))
'()
(cons '#(syntax-object
syntax-case
(top))
(cons '#(syntax-object
x
(top))
(cons _key
(map (lambda (__e1
__e2
__e3)
(cons __e1
(cons __e2
__e3)))
_e1
_e2
_e3)))))))
(list '#(syntax-object
let
(top))
(list (list _y
(list '#(syntax-object
syntax-dispatch
(top))
'#(syntax-object
x
(top))
(list '#(syntax-object
quote
(top))
_pattern)
(list '#(syntax-object
syntax
(top))
(list->vector
_key)))))
(list '#(syntax-object
if
(top))
(list '#(syntax-object
not
(top))
(list '#(syntax-object
eq?
(top))
_y
(list '#(syntax-object
quote
(top))
'#(syntax-object
no
(top)))))
_call
(list _dorest))))))
(car g00041)
(cadr g00041)
(caddr
g00041)
(cadddr
g00041))
(syntax-error
g00042)))
(syntax-dispatch
g00042
'(pair (any)
pair
(any)
pair
(any)
pair
(any)
atom)
(vector))))
(list (convert-syntax-dispatch-pattern
_pat
_key)
'#(syntax-object
y
(top))
'#(syntax-object
dorest
(top))
(syncase:build-dispatch-call
(extract-bound-syntax-ids
_pat
_key)
(list '#(syntax-object
if
(top))
_fender
_exp
(list '#(syntax-object
dorest
(top))))
'#(syntax-object
y
(top)))))
(g00040)))
g00038)
(g00040)))
(syntax-dispatch
g00039
'(pair (any)
pair
(any)
pair
(each any)
pair
(pair (any)
pair
(any)
pair
(any)
atom)
each
pair
(any)
pair
(any)
each
any)
(vector))))
(lambda ()
(syntax-error
g00039))))
g00036))))
g00033))))
g00030))))
x)))))))